home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / cl-nd-cl.lha / clue / clio / gravity.lisp < prev    next >
Encoding:
Text File  |  1991-07-16  |  10.0 KB  |  274 lines
  1. ;;; -*- Mode:Lisp; Package:CLIO-OPEN; Base:10; Lowercase:T; Syntax:Common-Lisp -*-
  2.  
  3.  
  4. ;;;----------------------------------------------------------------------------------+
  5. ;;;                                                                                  |
  6. ;;;                          TEXAS INSTRUMENTS INCORPORATED                          |
  7. ;;;                                  P.O. BOX 149149                                 |
  8. ;;;                             AUSTIN, TEXAS 78714-9149                             |
  9. ;;;                                                                                  |
  10. ;;;             Copyright (C) 1989, 1990 Texas Instruments Incorporated.             |
  11. ;;;                                                                                  |
  12. ;;; Permission is granted to any individual or institution to use, copy, modify, and |
  13. ;;; distribute this software, provided that  this complete copyright and  permission |
  14. ;;; notice is maintained, intact, in all copies and supporting documentation.        |
  15. ;;;                                                                                  |
  16. ;;; Texas Instruments Incorporated provides this software "as is" without express or |
  17. ;;; implied warranty.                                                                |
  18. ;;;                                                                                  |
  19. ;;;----------------------------------------------------------------------------------+
  20.  
  21. (in-package "CLIO-OPEN")
  22.  
  23. (export '(
  24.       gravity
  25.       *default-display-bottom-margin*
  26.       *default-display-left-margin*
  27.       *default-display-right-margin*
  28.       *default-display-top-margin*      
  29.       
  30.       display-bottom-margin
  31.       display-gravity
  32.       display-left-margin
  33.       display-right-margin
  34.       display-top-margin
  35.       )
  36.     'clio-open)
  37.  
  38. (deftype gravity ()
  39.   '(member :north-west :north :north-east
  40.        :east :center :west
  41.        :south-east :south :south-west))
  42.  
  43. (defparameter *default-display-bottom-margin* 0
  44.   "The default size of the bottom margin, in points.")
  45.  
  46. (defparameter *default-display-left-margin* 0
  47.   "The default size of the left margin, in points.")
  48.  
  49. (defparameter *default-display-right-margin* 0
  50.   "The default size of the right margin, in points.")
  51.  
  52. (defparameter *default-display-top-margin* 0
  53.   "The default size of the top margin, in points.")
  54.  
  55. ;; Special types to support conversion of resource defaults to pixel units
  56. (deftype default-bottom-margin () 'card16)
  57. (deftype default-left-margin   () 'card16)
  58. (deftype default-right-margin  () 'card16)
  59. (deftype default-top-margin    () 'card16)
  60.  
  61. (defmethod convert ((contact contact) (value (eql :default)) (type (eql 'default-bottom-margin)))
  62.   (point-pixels (contact-screen contact) *default-display-bottom-margin*))
  63.  
  64. (defmethod convert ((contact contact) (value (eql :default)) (type (eql 'default-left-margin)))
  65.   (point-pixels (contact-screen contact) *default-display-left-margin*))
  66.  
  67. (defmethod convert ((contact contact) (value (eql :default)) (type (eql 'default-right-margin)))
  68.   (point-pixels (contact-screen contact) *default-display-right-margin*))
  69.  
  70. (defmethod convert ((contact contact) (value (eql :default)) (type (eql 'default-top-margin)))
  71.   (point-pixels (contact-screen contact) *default-display-top-margin*))
  72.  
  73.  
  74.  
  75.  
  76. ;;;----------------------------------------------------------------------------+
  77. ;;;                                                                            |
  78. ;;;                                 gravity-mixin                              |
  79. ;;;                                                                            |
  80. ;;;----------------------------------------------------------------------------+
  81.  
  82. (defcontact gravity-mixin ()
  83.   ((bottom-margin    :type           default-bottom-margin 
  84.              :initarg         :bottom-margin
  85.              :reader         display-bottom-margin)           ; setf defined below
  86.    (right-margin     :type           default-right-margin 
  87.              :initarg         :right-margin
  88.              :reader         display-right-margin)           ; setf defined below
  89.    (gravity          :type           (or (member :tiled) gravity)      ; setf defined below
  90.              :initform       :center
  91.              :initarg        :display-gravity
  92.              :reader         display-gravity)
  93.    (clip-rectangle   :type           array
  94.              :initform       (make-array 4 :element-type 'integer)))
  95.   (:resources
  96.     (display-gravity :type (or (member :tiled) gravity)
  97.              :initform :center)
  98.     (bottom-margin :initform :default)
  99.     (right-margin  :initform :default)
  100.     (left-margin   :type     default-left-margin
  101.            :initform :default)
  102.     (top-margin    :type     default-top-margin
  103.            :initform :default))
  104.   
  105.   (:documentation  "Provides margin and gravity resources for core contacts."))
  106.  
  107.  
  108.  
  109. (defmacro display-clip-x (contact)
  110.   `(svref (slot-value ,contact 'clip-rectangle) 0))
  111.  
  112. (defmacro display-clip-y (contact)
  113.   `(svref (slot-value ,contact 'clip-rectangle) 1))
  114.  
  115. (defmacro display-clip-width (contact)
  116.   `(svref (slot-value ,contact 'clip-rectangle) 2))
  117.  
  118. (defmacro display-clip-height (contact)
  119.   `(svref (slot-value ,contact 'clip-rectangle) 3))
  120.  
  121. (defmethod update-clip-rectangle ((contact gravity-mixin))
  122.   (with-slots (clip-rectangle right-margin bottom-margin width height)
  123.     contact ;(the gravity-mixin contact)
  124.     (setf (display-clip-width  contact)
  125.       (max 0 (- width right-margin (display-clip-x contact)))
  126.       (display-clip-height contact)
  127.       (max 0 (- height bottom-margin (display-clip-y contact))))))
  128.  
  129. (defmethod update-bit-gravity ((contact gravity-mixin))
  130.   (with-slots (gravity)
  131.     contact (the gravity-mixin contact)
  132.        (setf (window-bit-gravity contact)
  133.          (cond
  134.            ;; If display-gravity is at a corner or margins are equal, then
  135.            ;; bit-gravity can equal display-gravity; 
  136.            ;; this minimizes exposure on resize.
  137.            ;; Otherwise, must use bit-gravity :forget and redisplay.
  138.            ((case gravity
  139.           ((:north :south)
  140.            (/= (display-left-margin contact) (display-right-margin contact)))
  141.           ((:west :east)
  142.            (/= (display-top-margin contact) (display-bottom-margin contact)))
  143.           (:center
  144.            (or (/= (display-left-margin contact)
  145.                (display-right-margin contact))
  146.                (/= (display-top-margin contact)
  147.                (display-bottom-margin contact)))))
  148.         :forget)
  149.  
  150.            ;; :tiled display-gravity is a special case...
  151.            ((eq gravity :tiled)
  152.         :north-west)
  153.  
  154.            (t
  155.         gravity)))))
  156.   
  157. (defmethod initialize-instance :after ((contact gravity-mixin)
  158.                        &key top-margin left-margin (display-gravity :center)
  159.                        &allow-other-keys)
  160.   (assert (or (typep display-gravity 'gravity) (eq display-gravity :tiled))
  161.       () "~s is not :tiled or a gravity"
  162.       display-gravity)
  163.   (setf (display-clip-x contact) left-margin
  164.     (display-clip-y contact) top-margin)
  165.        (update-clip-rectangle contact))
  166.   
  167.   
  168. (defmethod (setf display-bottom-margin) (new-value (contact gravity-mixin))
  169.   (with-slots (bottom-margin) 
  170.     contact
  171.     (let ((new-value (if (eq new-value :default)
  172.              (convert contact new-value 'default-bottom-margin)
  173.              new-value)))
  174.       (check-type new-value card16)
  175.       (setf bottom-margin new-value)
  176.       (update-clip-rectangle contact)
  177.       (when (realized-p contact)
  178.     (update-bit-gravity contact)
  179.     (clear-area contact :exposures-p t))
  180.       new-value)))
  181.   
  182. (defmethod (setf display-right-margin) (new-value (contact gravity-mixin))
  183.   (with-slots (right-margin)
  184.     contact
  185.     (let ((new-value (if (eq new-value :default)
  186.              (convert contact new-value 'default-right-margin)
  187.              new-value)))
  188.       (check-type new-value card16)
  189.       (setf right-margin new-value)
  190.       (update-clip-rectangle contact)
  191.       (when (realized-p contact)
  192.     (update-bit-gravity contact)
  193.     (clear-area contact :exposures-p t))
  194.       new-value)))
  195.   
  196.   
  197. (defmethod (setf display-left-margin) (new-value (contact gravity-mixin))
  198.   (with-slots (clip-rectangle)
  199.     contact
  200.     (let ((new-value (if (eq new-value :default)
  201.              (convert contact new-value 'default-left-margin)
  202.              new-value)))
  203.       (check-type new-value card16)
  204.       (setf (display-clip-x contact) new-value)
  205.       (update-clip-rectangle contact)
  206.       (when (realized-p contact)
  207.     (update-bit-gravity contact)
  208.     (clear-area contact :exposures-p t))
  209.       new-value)))
  210.   
  211. (defmethod display-left-margin ((contact gravity-mixin))
  212.   (display-clip-x contact))
  213.   
  214.   
  215. (defmethod (setf display-top-margin) (new-value (contact gravity-mixin))
  216.   (with-slots (clip-rectangle)
  217.     contact
  218.     (let ((new-value (if (eq new-value :default)
  219.              (convert contact new-value 'default-top-margin)
  220.              new-value)))
  221.       (check-type new-value card16)
  222.       (setf (display-clip-y contact) new-value)
  223.       (update-clip-rectangle contact)
  224.       (when (realized-p contact)
  225.     (update-bit-gravity contact)
  226.     (clear-area contact :exposures-p t))
  227.       new-value)))
  228.   
  229. (defmethod display-top-margin ((contact gravity-mixin))
  230.   (display-clip-y contact))
  231.   
  232.   
  233. (defmethod resize :after ((contact gravity-mixin) width height border-width)
  234.        (declare (ignore width height border-width))
  235.        (update-clip-rectangle contact))
  236.  
  237. (defmethod (setf display-gravity) :after (new-value (contact gravity-mixin))
  238.   (declare (ignore new-value))
  239.   (when (realized-p contact)
  240.     (update-bit-gravity contact)
  241.     (clear-area contact :exposures-p t)))
  242.  
  243. (defmethod realize :after ((contact gravity-mixin))
  244.        (update-bit-gravity contact))
  245.  
  246. (defmethod (setf display-gravity) (new-value (contact gravity-mixin))
  247.   (check-type new-value gravity)
  248.   (setf (slot-value contact 'gravity) new-value))
  249.  
  250.  
  251.  
  252.  
  253. (defmethod preferred-size :around ((contact gravity-mixin) &key width height border-width)
  254.   (let
  255.     ((tm (display-top-margin contact))
  256.      (bm (display-bottom-margin contact))
  257.      (lm (display-left-margin contact))
  258.      (rm (display-right-margin contact)))
  259.  
  260.     ;; Get preferred-size with margins subtracted from suggested size, then add
  261.     ;; margins back in to get preferred size including margins.
  262.     (multiple-value-bind (pw ph pbw)
  263.     (call-next-method
  264.       contact
  265.       :width        (max 0 (- (or width (contact-width contact)) lm rm))
  266.       :height       (max 0 (- (or height (contact-height contact)) tm bm))
  267.       :border-width (or border-width (contact-border-width contact)))
  268.       
  269.       (values
  270.     (+ pw lm rm)
  271.     (+ ph tm bm)
  272.     pbw))))
  273.  
  274.